unit uDZWuManber;

interface

uses
  SysUtils, Classes, uDZTypes, uDZSysUtils, uDZMultiPatternMatch;

type
  PdzWuManberPattern = ^TWuManberPattern;
  TWuManberPattern = record
    len: TUnsignedShort;
    prefix: TUnsignedShort;
    tag: TObject;
    next: PdzWuManberPattern;
  end;
  PPdzWuManberPattern = ^PdzWuManberPattern;

  TWuManberShift = record
    hash: TUnsignedLong;
    shift: TUnsignedLong;
    suffix: PdzWuManberPattern;
  end;
  PdzWuManberShift = ^TWuManberShift;
  PPdzWuManberShift = ^PdzWuManberShift;

  IWuManberShiftTableA = interface(IDictionary)
  ['{38EB7C5A-459D-4A4C-A237-67BA6447AD81}']
    function GetItem(key: PAnsiChar): PdzWuManberShift;
    procedure SetItem(key: PAnsiChar; value: PdzWuManberShift);
    function GetCaseSensitive: Boolean;
    procedure SetCaseSensitive(value: Boolean);
    function Find(key: PAnsiChar; data: PPdzWuManberShift): Boolean;
    function Erase(key: PAnsiChar): Boolean;
    function Insert(
      key: PAnsiChar;
      value: PdzWuManberShift;
      internal: PPointer;
      replaceIfExists: Boolean): Boolean;

    property Item[key: PAnsiChar]: PdzWuManberShift
      read GetItem write SetItem;
    property CaseSensitive: Boolean read GetCaseSensitive
      write SetCaseSensitive;
  end;

  TWuManberShiftTableA = class(THashTable, IWuManberShiftTableA)
  private
    FCaseSensitive: Boolean;
    function GetCaseSensitive: Boolean;
    procedure SetCaseSensitive(value: Boolean);
  protected
    function GetItem(key: PAnsiChar): PdzWuManberShift;
    procedure SetItem(key: PAnsiChar; value: PdzWuManberShift);
    procedure AssignKey(
      src: Pointer;
      dest: Pointer); override;
    procedure AssignValue(
      src: Pointer;
      dest: Pointer); override;
    function CompareKey(
      key1: Pointer;
      key2: Pointer): Boolean; override;
    function HashKey(key: Pointer): Integer; override;
    function GetIterator: IIterator; override;
  public
    constructor Create(
      _blockChars: Integer;
      _tableSize: Integer;
      _caseSensitive: Boolean;
      fnHash: THashFunction);
    function Find(key: PAnsiChar; value: PPdzWuManberShift): Boolean;
    function Erase(key: PAnsiChar): Boolean;
    function Insert(
      key: PAnsiChar;
      value: PdzWuManberShift;
      internal: PPointer;
      replaceIfExists: Boolean): Boolean;
  end; 


  TWuManber = class(TInterfacedObject,
                      IMultiPatternMatchA)
  private
    FPatterns: PPdzWuManberPattern;
    FPatternData: PdzWuManberPattern;
    FPatternCount: TUnsignedLong;
    FCaseSensitive: Boolean;
    FBlockLen: TUnsignedLong;
    FMinPatternLen: TUnsignedLong;
    FShiftTable: IWuManberShiftTableA;
    FShiftArray: PdzWuManberShift;
  protected
    function GetCaseSensitive: Boolean;
    procedure SetCaseSensitive(sensitive: Boolean);
    procedure BuildShiftTable;
  public
    constructor Create;
    destructor Destroy; override;
	  function Initialize(
      patternList: IAnsiStringList): Boolean;
    procedure Cleanup;
    function Macth(
      text: PAnsiChar;
      textLen: TUnsignedLong;
      entries: PdzStringMatchEntryA;
      entryCount: TUnsignedLong;
      method: TMatchMethod): TUnsignedLong;
    property MinPatternLen: TUnsignedLong read FMinPatternLen;
    property BlockLen: TUnsignedLong read FBlockLen;
    property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive;
    property PatternCount: TUnsignedLong read FPatternCount;
  end;

implementation

{ TWuManber }

procedure TWuManber.BuildShiftTable;
var
  i, j: TUnsignedLong;
  spat, sblk: PAnsiChar;
  pat: PPdzWuManberPattern;
  sh, shift: PdzWuManberShift;
begin
  FShiftTable := TWuManberShiftTableA.Create(
    FBlockLen,
    CalcHashTableSize(1),
    FCaseSensitive,
    DEFAULT_HASH_ROUTINE);

  (*  *)
  pat := FPatterns;
	for i := 0 to FPatternCount - 1 do
  begin
    spat := PAnsiChar(pat^) + SizeOf(TWuManberPattern);
    j := FMinPatternLen - 1;
    while (j >= FBlockLen - 1) do
    begin
      FShiftTable.Insert(
        spat + j - FBlockLen,
        nil,
        nil,
        True);
      Dec(j);
    end;
    Inc(pat);
  end;

  FShiftArray := PdzWuManberShift(System.GetMemory(
    SizeOf(TWuManberShift) * FShiftTable.Size));
  sh := FShiftArray;
  for I := 0 to FShiftTable.Size - 1 do
  begin
    sh.shift := TUnsignedLong(-1);
    sh.suffix := nil;
    Inc(sh);
  end;
  sh := FShiftArray;

  FShiftTable.Clear;
  pat := FPatterns;
	for i := 0 to FPatternCount - 1 do
  begin
    spat := PAnsiChar(pat^) + SizeOf(TWuManberPattern);
    j := FMinPatternLen - 1;
    while (j >= FBlockLen - 1) do
    begin
      sblk := spat + j - FBlockLen;
      if (not FShiftTable.Find(sblk, @shift)) then
      begin
        FShiftTable.Insert(sblk, sh, nil, True);
        shift := sh;
        Inc(sh);
      end;
      if (j = FMinPatternLen - 1) then
      begin
        shift.shift := 0;
        pat^.next := shift.suffix;
        shift.suffix := pat^;
      end
      else begin
        if (shift.shift > FMinPatternLen - 1 - j) then
          shift.shift := FMinPatternLen - 1 - j;
      end;
      Dec(j);
    end;
    Inc(pat);
  end;
end;

procedure TWuManber.Cleanup;
begin
  if (FShiftArray <> nil) then
  begin
    System.FreeMemory(FShiftArray);
    FShiftArray := nil;
  end;
  if (FPatternData <> nil) then
  begin
    System.FreeMemory(FPatternData);
    FPatternData := nil;
  end;
  if (FPatterns <> nil) then
  begin
    System.FreeMemory(FPatterns);
    FPatterns := nil;
  end;
end;

constructor TWuManber.Create;
begin

end;

destructor TWuManber.Destroy;
begin
  Cleanup;
  inherited;
end;

function TWuManber.GetCaseSensitive: Boolean;
begin
  Result := FCaseSensitive;
end;

function TWuManber.Initialize(
  patternList: IAnsiStringList): Boolean;
var
  i: TUnsignedLong;
  totalLen: TUnsignedLong;
  pat: PdzWuManberPattern;
  ppat: PPdzWuManberPattern;
  len: TUnsignedShort;
  spat: PAnsiChar;
begin
  FPatternCount := patternList.Size;
	FPatterns := PPdzWuManberPattern(
    System.GetMemory(
      SizeOf(PdzWuManberPattern) * FPatternCount));
  FMinPatternLen := TUnsignedLong(-1);
	totalLen := 0;

	(* get the shortest pattern's length *)
	for i := 0 to FPatternCount - 1 do
  begin
    len := Length(patternList.Item[i]);
    if (len < FMinPatternLen) then
      FMinPatternLen := len;
    Inc(totalLen, len + 1);
  end;

  if (FMinPatternLen < 3) then
    FBlockLen := FMinPatternLen
  else
    FBlockLen := 3;

	FPatternData := PdzWuManberPattern(System.GetMemory
    (SizeOf(TWuManberPattern) * FPatternCount + totalLen));

  pat := FPatternData;
  ppat := FPatterns;
	for i := 0 to FPatternCount - 1 do
  begin
    len := Length(patternList.Item[i]);
    spat := PAnsiChar(patternList.Item[i]);
    pat.len := len;
    pat.next := nil;
    Move(spat^, PAnsiChar(pat)[SizeOf(TWuManberPattern)], len);
    PAnsiChar(pat)[SizeOf(TWuManberPattern) + len] := #0;
    ppat^ := pat;
    Inc(ppat);
    Inc(PAnsiChar(pat), len + SizeOf(TWuManberPattern) + 1);
  end;
  
	BuildShiftTable;

  Result := True;
end;

function TWuManber.Macth(
  text: PAnsiChar;
  textLen: TUnsignedLong;
  entries: PdzStringMatchEntryA;
  entryCount: TUnsignedLong;
  method: TMatchMethod): TUnsignedLong;
var
  shift, i, j, matched: TUnsignedLong;
  sublen: TUnsignedShort;
  ptr, ptrstart, textend, substr: PAnsiChar;
  domatch: Boolean;
  pat: PdzWuManberPattern;
  sh: PdzWuManberShift;
begin
	if (textLen = TUnsignedLong(-1)) then
    textLen := StrLen(text);

	if (textLen < FMinPatternLen) then
  begin
    Result := 0;
    Exit;
  end;  

	textend := text + textLen;
	ptr := text + (FMinPatternLen - 1);

	matched := 0;

	while (ptr < textend) do
  begin
    FShiftTable.Find(
      ptr - FBlockLen, @sh );
    shift := sh.shift;
		if (shift = 0) then
		begin
			pat := sh.suffix;
			ptrstart := ptr - (FMinPatternLen - 1);
			while (pat <> nil) do
			begin
				substr := PAnsiChar(pat) + SizeOf(TWuManberPattern);
				sublen := pat.len;
				case method of
          MATCH_BEGIN:
					  domatch := (ptrstart + sublen <= textend);
          MATCH_END:
					  domatch := ptrstart + sublen = textend;
          MATCH_CONTAIN:
					  domatch := ptrstart + sublen <= textend;
          else
            domatch := False;
        end;
				if (domatch) then
				begin
          j := sublen;
					for i := 0 to sublen -1 do
					begin
						if (ptrstart[i] <> substr[i]) then
            begin
              j := i;
              Break;
            end;
					end;
					if (j = sublen) then 
					begin
						if (matched < entryCount) then
						begin
							entries.pattern := substr;
							entries.offset := ptrstart;
              entries.patternLen := sublen;
              entries.tag := pat.tag;
              Inc(entries);
							Inc(matched);	
						end;
						if (matched >= entryCount) then
            begin
              Result := matched;
              Exit;
            end;
					end;
        end;
				pat := pat.next;
			end;
			shift := 1;
		end;
		Inc(ptr, shift);
	end;
	Result := matched;
end;

procedure TWuManber.SetCaseSensitive(
  sensitive: Boolean);
begin
  FCaseSensitive := sensitive;
end;

{ TWuManberShiftTableA }

procedure TWuManberShiftTableA.AssignValue(
  src: Pointer;
  dest: Pointer);
begin
  PPdzWuManberShift(dest)^ := PPdzWuManberShift(src)^;
end;

function TWuManberShiftTableA.CompareKey(
  key1: Pointer;
  key2: Pointer): Boolean;
var
  options: TStringCompareOptions;
begin
  if (FCaseSensitive) then
    options := []
  else
    options := [coIgnoreCase];
  Result := (crEqual = AnsiCompare(
    PAnsiChar(key1),
    KeySize,
    PAnsiChar(key2),
    KeySize,
    options));
end;

procedure TWuManberShiftTableA.AssignKey(
  src: Pointer;
  dest: Pointer);
begin
  Move(src^, dest^, KeySize);  
end;

constructor TWuManberShiftTableA.Create(
  _blockChars: Integer;
  _tableSize: Integer;
  _caseSensitive: Boolean;
  fnHash: THashFunction);
begin
  inherited Create(
    _blockChars,
    SizeOf(Pointer),
    _tableSize,
    fnHash);
  FCaseSensitive := _caseSensitive;
end;

function TWuManberShiftTableA.Erase(
  key: PAnsiChar): Boolean;
begin
  Result := _Erase(Pointer(key));
end;

function TWuManberShiftTableA.Find(
  key: PAnsiChar;
  value: PPdzWuManberShift): Boolean;
var
  valuePos: PPdzWuManberShift;
begin
  if (_Find(Pointer(key), @valuePos)) then
  begin
    if (value <> nil) then
      value^ := valuePos^;
    Result := True;
  end
  else Result := False;
end;

function TWuManberShiftTableA.GetCaseSensitive: Boolean;
begin
  Result := FCaseSensitive;
end;

function TWuManberShiftTableA.GetItem(
  key: PAnsiChar): PdzWuManberShift;
begin
  Result := PPdzWuManberShift(
    inherited _GetItem(Pointer(key)))^;
end;

function TWuManberShiftTableA.GetIterator: IIterator;
begin
  Result := nil;
end;

function TWuManberShiftTableA.HashKey(
  key: Pointer): Integer;
begin
  Result := FHashFunction(
    PAnsiChar(key),
    KeySize,
    TCharCase(FCaseSensitive));
end;

function TWuManberShiftTableA.Insert(
  key: PAnsiChar;
  value: PdzWuManberShift;
  internal: PPointer;
  replaceIfExists: Boolean): Boolean;
begin
  Result := inherited _Insert(
    Pointer(key),
    @value,
    internal,
    replaceIfExists);
end;

procedure TWuManberShiftTableA.SetCaseSensitive(
  value: Boolean);
begin
  FCaseSensitive := value;
end;

procedure TWuManberShiftTableA.SetItem(
  key: PAnsiChar;
  value: PdzWuManberShift);
begin
  _SetItem(Pointer(key), @value);
end;

end.
